home *** CD-ROM | disk | FTP | other *** search
/ HAM Radio 1997 / HAM Radio 1997.iso / vcls / transpar / trnsrad.pas < prev   
Pascal/Delphi Source File  |  1996-04-08  |  8KB  |  315 lines
  1. { THIS IS MY FIRST ATTEMPT AT A COMPOENENT, IT IS A TRANSPARENT 
  2.   RADIO BUTTON WITH COLOR OPTIONS.
  3.  
  4.   Sgt Galen Smallen
  5.   EIelson AFBm, AK
  6. }
  7.  
  8. unit Transrad;
  9.  
  10. interface
  11.  
  12. uses
  13.   SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
  14.   Forms, Dialogs, StdCtrls, ExtCtrls, Menus;
  15.  
  16. type
  17.   TTransRadioButton = class(TCustomControl)
  18.   private
  19.     FDown:Boolean;
  20.     FCheckedColor:TColor;
  21.     FGroupIndex:Byte;
  22.     FChecked: Boolean;
  23.     procedure TurnSiblingsOff;
  24.     function GetTransparent: Boolean;
  25.     Procedure SetTransparent(Value: Boolean);
  26.     procedure WMSetFocus(var Message: TWMSetFocus); message WM_SETFOCUS;
  27.     procedure CMCtl3DChanged(var Message: TMessage); message CM_CTL3DCHANGED;
  28.     procedure CMDialogChar(var Message: TCMDialogChar); message CM_DIALOGCHAR;
  29.     procedure CNCommand(var Message: TWMCommand); message CN_COMMAND;
  30.   protected
  31.     procedure SetDown(Value:Boolean);
  32.     procedure SetCheckedColor(Value:TColor);
  33.     constructor Create(AOwner: TComponent); override;
  34.     procedure SetChecked(Value: Boolean);
  35.     procedure Paint; override;
  36.     procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
  37.       X, Y: Integer); override;
  38.     procedure MouseUp(Button: TMouseButton; Shift: TShiftState;
  39.       X, Y: Integer); override;
  40.     procedure DoEnter; override;
  41.     procedure DoExit; override;
  42.     function  GetCaption: TCaption;
  43.     procedure SetCaption(const Value:TCaption);
  44.     procedure CreateWnd; override;
  45.  
  46.   public
  47.     property canvas;
  48.   published
  49.     property Caption: TCaption read GetCaption write SetCaption;
  50.     property CheckedOnColor:TColor read FCheckedColor write SetCheckedColor
  51.              default clbtnShadow;
  52.     property Checked: Boolean read FChecked write SetChecked default False;
  53.     property Ctl3d;
  54.     property Down:Boolean read FDown write SetDown default False;
  55.     property DragCursor;
  56.     property DragMode;
  57.     property Enabled;
  58.     property Font;
  59.     property GroupIndex:Byte read FGroupIndex write FGroupIndex
  60.       default 0;
  61.     property ShowHint;
  62.     property TabOrder;
  63.     property TabStop;
  64.     property Transparency: Boolean Read GetTransparent Write SetTransParent default True;
  65.     property Visible;
  66.     property OnClick;
  67.     property OnDblClick;
  68.     property OnDragDrop;
  69.     property OnDragOver;
  70.     property OnEndDrag;
  71.     property OnEnter;
  72.     property OnExit;
  73.     property OnKeyDown;
  74.     property OnKeyPress;
  75.     property OnKeyUp;
  76.     property OnMouseDown;
  77.     property OnMouseMove;
  78.     property OnMouseUp;
  79.   end;
  80.  
  81. procedure Register;
  82.  
  83. implementation
  84.  
  85. const bw=12;
  86.  
  87. procedure Register;
  88. begin
  89.   RegisterComponents('NewTools', [TTransRadioButton]);
  90. end;
  91. constructor TTransRadioButton.Create(AOwner: TComponent);
  92. begin
  93.   inherited Create(AOwner);
  94.   Width := 150;
  95.   Height := 17;
  96. end;
  97.  
  98. procedure TTransRadioButton.TurnSiblingsOff;
  99.  
  100. var i:Integer;
  101.     Sibling: TTransRadioButton;
  102.  
  103. begin
  104.      if Parent <> nil then
  105.        for i:=0 to Parent.ControlCount-1 do
  106.          if Parent.Controls[i] is TTransRadioButton then
  107.            begin
  108.              Sibling:=TTransRadioButton(Parent.Controls[i]);
  109.              if (Sibling<>Self) and
  110.                 (Sibling.GroupIndex=GroupIndex) then
  111.                   Sibling.SetChecked(False);
  112.            end;
  113. end;
  114.  
  115. function TTransRadioButton.GetTransparent: Boolean;
  116. begin
  117.   Result := not (csOpaque in ControlStyle);
  118. end;
  119.  
  120. procedure TTransRadioButton.SetTransparent(Value: Boolean);
  121. begin
  122.   if Transparency <> Value then
  123.   begin
  124.     if Value then
  125.       ControlStyle := ControlStyle - [csOpaque] else
  126.       ControlStyle := ControlStyle + [csOpaque];
  127.     Invalidate;
  128.   end;
  129. end;
  130.  
  131. procedure TTransRadioButton.Paint;
  132. var
  133.   H: Integer;
  134.   R: TRect;
  135.   C: array [Byte] of Char;
  136.   CLen: Integer;
  137.   BL,BT,BR,BB,BM:Integer;
  138.     TX,TY,TW,TH:Integer;
  139.     CX,CY:Integer;
  140.     BRect:TRect;
  141. begin
  142.      Canvas.Font:=Font;
  143.      with Canvas do
  144.        begin
  145.          BM:=12 div 2;
  146.          BT:=(Height div 2)-BM;
  147.          BB:=BT+12;
  148.          BL:=1;
  149.          BR:= 12+1;
  150.          if not FDOWN then
  151.            begin
  152.              Pen.Color:= clbtnShadow;
  153.              Arc(BL,BT,BR,BB,BR,BT,BL,BB);
  154.              Pen.Color:= clbtnHighlight;
  155.              Arc(BL,BT,BR,BB,BL,BB,BR,BT);
  156.              Pen.Color:= clBlack;
  157.              Brush.Color := clBtnFace;
  158.              Ellipse(BL+2,Bt+2,BR-2,BB-2);
  159.              end
  160.          else
  161.            begin
  162.              if Checked then Pen.Color:= ClbtnShadow
  163.                         else Pen.Color:= ClbtnHighlight;
  164.              Arc(BL,BT,BR,BB,BR,BT,BL,BB);
  165.              if Checked then Pen.Color:= ClbtnHighlight
  166.                         else Pen.Color:= ClbtnShadow;
  167.              Arc(BL,BT,BR,BB,BL,BB,BR,BT);
  168.            end;
  169.          if Checked then
  170.             begin
  171.               Pen.Color:= CheckedOnColor;
  172.               Brush.Color := CheckedOnColor;
  173.               Ellipse(BL+2,BT+2,BR-2,BB-2);
  174.             end;
  175.             Brush.Color := clBtnFace;
  176.          TX:=BR+5;
  177.          TY:=(Height div 2)+(Font.Height div 2)-1;
  178.          if Transparency then
  179.          begin
  180.          SetBkMode(Handle,TRANSPARENT);
  181.          SetBkColor(Handle,Font.Color);
  182.          end;
  183.          SetTextColor(Handle,Font.Color);
  184.          TW:=TextWidth(Caption);
  185.          TH:=TextHeight(Caption);
  186.          TextOut(TX,TY,Caption);
  187.          BRect:=Bounds(TX-1,TY,TW+3,TH+1);
  188.          DrawText(Handle, C, CLen, R, DT_LEFT or DT_SINGLELINE);
  189.      end;
  190. end;
  191. procedure TTransRadioButton.SetDown(Value:Boolean);
  192.  
  193. begin
  194.      if FDown<>Value then
  195.        begin
  196.          FDown:=Value;
  197.          Paint;
  198.        end;
  199. end;
  200. procedure TTransRadioButton.DoEnter;
  201.  
  202. begin
  203.      inherited DoEnter;
  204.      Checked:=True;
  205.      Paint;
  206. end;
  207.  
  208. procedure TTransRadioButton.DoExit;
  209.  
  210. begin
  211.      inherited DoExit;
  212.      Checked := False;
  213.      Paint;
  214. end;
  215.  
  216. procedure TTransRadioButton.MouseDown(Button: TMouseButton; Shift: TShiftState;
  217.                                   X, Y: Integer);
  218.  
  219. begin
  220.      inherited MouseDown(Button, Shift, X, Y);
  221.      Down:=True;
  222. end;
  223.  
  224. procedure TTransRadioButton.MouseUp(Button: TMouseButton; Shift: TShiftState;
  225.                                   X, Y: Integer);
  226.  
  227. begin
  228.      Down:=False;
  229.      if (X>=0) and (X<=Width) and (Y>=0) and (Y<=Height)
  230.        and not Checked then Checked:=True;
  231.      inherited MouseUp(Button, Shift, X, Y);
  232. end;
  233. function TTransRadioButton.GetCaption:TCaption;
  234.  
  235. var Len:Integer;
  236.  
  237. begin
  238.      Len := GetTextBuf(@Result, 256);
  239.      Move(Result[0], Result[1], Len);
  240.      Result[0] := Char(Len);
  241. end;
  242.  
  243. procedure TTransRadioButton.SetCaption(const Value:TCaption);
  244.  
  245. var Buffer: array[0..255] of Char;
  246.  
  247. begin
  248.      if GetCaption <> Value then
  249.        SetTextBuf(StrPCopy(Buffer,Value));
  250.      Invalidate;
  251. end;
  252.  
  253. procedure TTransRadioButton.SetChecked(Value: Boolean);
  254.  
  255. begin
  256.      if FChecked <> Value then
  257.        begin
  258.          TabStop:=Value;
  259.          FChecked:=Value;
  260.          if Value then
  261.            begin
  262.              TurnSiblingsOff;
  263.              Click;
  264.            end;
  265.          Paint;
  266.        end;
  267. end;
  268.  
  269. procedure TTransRadioButton.SetCheckedColor(Value:TColor);
  270.  
  271. begin
  272.      FCheckedColor:=Value;
  273.      Paint;
  274. end;
  275.  
  276. procedure TTransRadioButton.CreateWnd;
  277. begin
  278.   inherited CreateWnd;
  279.   SendMessage(Handle, BM_SETCHECK, Cardinal(FChecked), 0);
  280.   if Ctl3D and (Ctl3DBtnWndProc <> nil) then
  281.     DefWndProc := Ctl3DBtnWndProc;
  282. end;
  283. procedure TTransRadioButton.WMSetFocus(var Message: TWMSetFocus);
  284. begin
  285.   if Ctl3D and (Ctl3DBtnWndProc <> nil) then UpdateWindow(Handle);
  286.   inherited;
  287. end;
  288.  
  289. procedure TTransRadioButton.CMCtl3DChanged(var Message: TMessage);
  290. begin
  291.   RecreateWnd;
  292. end;
  293.  
  294. procedure TTransRadioButton.CMDialogChar(var Message: TCMDialogChar);
  295. begin
  296.   with Message do
  297.     if IsAccel(Message.CharCode, Caption) and CanFocus then
  298.     begin
  299.       SetFocus;
  300.       Result := 1;
  301.     end else
  302.       inherited;
  303. end;
  304.  
  305. procedure TTransRadioButton.CNCommand(var Message: TWMCommand);
  306. begin
  307.   case Message.NotifyCode of
  308.     BN_CLICKED: SetChecked(True);
  309.     BN_DOUBLECLICKED: DblClick;
  310.   end;
  311. end;
  312.  
  313. end.
  314.  
  315.